home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / jockguts.arc / MISCTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-28  |  18KB  |  694 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.01                              }
  5. {                                                                          }
  6. {                                                                          }
  7. {              Copyright 1986, 1989 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}                                       
  13.                      {       Unit:  MiscTTT5          }
  14.                      {--------------------------------}
  15.  
  16.  
  17. {$S-,R-,V-,D-}       
  18.  
  19. Unit MiscTTT5;
  20. {Change History : April 1, 1989    Modified Printer Status and added global
  21.                                    LPTport 
  22. }
  23. Interface
  24.  
  25. Uses CRT, DOS, FastTTT5, Strnttt5;
  26.  
  27. TYPE
  28.    Dates = word;   {change to longint for greater date ranges}
  29.  
  30. CONST
  31.    MMDDYY   = 1;   {Date formats}
  32.    MMDDYYYY = 2;
  33.    MMYY     = 3;
  34.    MMYYYY   = 4;
  35.    DDMMYY   = 5;
  36.    DDMMYYYY = 6;
  37.  
  38. VAR
  39.    LPTport,     {0=lpt1, 1=lpt2, 2=lpt3}
  40.    ClockX,
  41.    ClockY,
  42.    ClockF,
  43.    ClockB : byte;
  44.  
  45. Function  Exist(Filename:string):boolean;
  46. Function  CopyFile(SourceFile, TargetFile:string): byte;
  47. Function  File_Size(Filename:string): longint;
  48. {$IFDEF VER50}
  49. Function  File_Drive(Full:string): string;
  50. Function  File_Directory(Full:string): string;
  51. Function  File_Name(Full:string): string;
  52. Function  File_Ext(Full:string): String;
  53. {$ENDIF}
  54. Function  Time: string;
  55. Procedure Clock;
  56. Function  Date: String;
  57. Procedure PrintScreen;
  58. Procedure Beep;
  59. function  Printer_Status:byte;
  60. Function  Alternate_Printer_Status:byte;
  61. Function  Printer_ready:boolean;
  62. Procedure FlushKeyBuffer;
  63. Procedure Reset_Printer;
  64. Function  DMY_to_String(D,M,Y:word;format:byte): string;
  65. Function  Date_To_Julian(InDate:string;format:byte): dates;
  66. Function  Julian_to_Date(J:dates;format:byte):string;
  67. Function  Today_in_Julian: dates;
  68. Function  Date_Within_Range(Min,Max,Test:dates):boolean;
  69. Function  Valid_Date(Indate:string;format:byte): boolean;
  70. Function  Future_Date(InDate:string;format:byte;Days:word): string;
  71. Function  Unformatted_date(InDate:string): string;
  72.  
  73. Implementation
  74.  
  75. Const
  76.     LastYearNextCentuary = 78;
  77.  
  78. Function Exist(Filename:string):boolean;
  79. {returns true if file exists}
  80. var Inf: SearchRec;
  81. begin
  82.     FindFirst(Filename,AnyFile,Inf);
  83.     Exist := (DOSError = 0);
  84. end;  {Func Exist}
  85.  
  86. Function CopyFile(SourceFile, TargetFile:string): byte;
  87. {return codes:  0 successful
  88.                 1 source and target the same
  89.                 2 cannot open source
  90.                 3 unable to create target
  91.                 4 error during copy
  92. }
  93. var
  94.   Source,
  95.   Target : file;
  96.   BRead,
  97.   Bwrite : word;
  98.   FileBuf  : array[1..2048] of char;
  99. begin
  100.     If SourceFile = TargetFile then
  101.     begin
  102.         CopyFile := 1;
  103.         exit;
  104.     end;
  105.     Assign(Source,SourceFile);
  106.     {$I-}
  107.     Reset(Source,1);
  108.     {$I+}
  109.     If IOResult <> 0 then
  110.     begin
  111.         CopyFile := 2;
  112.         exit;
  113.     end;
  114.     Assign(Target,TargetFile);
  115.     {$I-}
  116.     Rewrite(Target,1);
  117.     {$I+}
  118.     If IOResult <> 0 then
  119.     begin
  120.         CopyFile := 3;
  121.         exit;
  122.     end;
  123.     Repeat
  124.          BlockRead(Source,FileBuf,SizeOf(FileBuf),BRead);
  125.          BlockWrite(Target,FileBuf,Bread,Bwrite);
  126.     Until (Bread = 0) or (Bread <> BWrite);
  127.     Close(Source);
  128.     Close(Target);
  129.     If Bread <> Bwrite then
  130.        CopyFile := 4
  131.     else
  132.        CopyFile := 0;
  133. end; {of func CopyFile}
  134.  
  135.  Function File_Size(Filename:string): longint;
  136.  {returns  -1   if file not found}
  137.  var
  138.     F : file of byte;
  139.  begin
  140.      Assign(F,Filename);
  141.      {$I-}
  142.      Reset(F);
  143.      {$I+}
  144.      If IOResult <> 0 then
  145.      begin
  146.         File_Size := -1;
  147.         exit;
  148.      end;
  149.      File_Size := FileSize(F);
  150.      Close(F);
  151.  end; {of func File_Size}
  152.  
  153. {$IFDEF VER50}
  154.  Function File_Split(Part:byte;Full:string): string;
  155.  {used internally}
  156.  var
  157.     D : DirStr;
  158.     N : NameStr;
  159.     E : ExtStr;
  160.  begin
  161.      FSplit(Full,D,N,E);
  162.      Case Part of
  163.      1 : File_Split := D;
  164.      2 : File_Split := N;
  165.      3 : File_Split := E;
  166.      end;
  167.  end; {of func File_Split}
  168.  
  169.  Function File_Drive(Full:string): string;
  170.  {}
  171.  var
  172.    Temp : string;
  173.    P : byte;
  174.  begin
  175.      Temp := File_Split(1,Full);
  176.      P := Pos(':',Temp);
  177.      If P <> 2 then
  178.         File_Drive := ''
  179.      else
  180.         File_Drive := upcase(Temp[1]);
  181.  end; {of func File_Drive}
  182.  
  183.  Function File_Directory(Full:string): string;
  184.  {}
  185.  var
  186.    Temp : string;
  187.    P : byte;
  188.  begin
  189.      Temp := File_Split(1,Full);
  190.      P := Pos(':',Temp);
  191.      If P = 2 then
  192.         Delete(Temp,1,2);                 {remove drive}
  193.      If (Temp[length(Temp)]  ='\') and (temp <> '\') then
  194.         Delete(temp,length(Temp),1);      {remove last backslash}
  195.      File_Directory := Temp;
  196.  end; {of func File_Directory}
  197.  
  198.  Function File_Name(Full:string): string;
  199.  {}
  200.  begin
  201.      File_Name := File_Split(2,Full);
  202.  end; {of func File_Name}
  203.  
  204.  Function File_Ext(Full:string): String;
  205.  {}
  206.  var
  207.    Temp : string;
  208.  begin
  209.      Temp := File_Split(3,Full);
  210.      If (Temp = '') or (Temp = '.') then
  211.         File_Ext := temp
  212.      else
  213.         File_Ext := copy(Temp,2,3);
  214.  end; {of func File_Ext}
  215. {$ENDIF}
  216. function time: string;
  217. var
  218.   hour,min,sec:     string[2];
  219.   H,M,S,T : word;
  220. begin
  221.     GetTime(H,M,S,T);
  222.     Str(H,Hour);
  223.     Str(M,Min);
  224.     Str(S,Sec);
  225.     if S < 10 then            {pad a leading zero if sec is < 10 }
  226.       sec := '0'+sec;
  227.     if M < 10 then            {pad a leading zero if min is < 10 }
  228.         min := '0'+min;
  229.     if H > 12 then           { assign an a.m. or p.m. string }
  230.     begin
  231.        str(H - 12,hour);
  232.        IF length(hour) = 1 then Hour := ' '+hour;
  233.           time := hour+':'+min+':'+sec+' p.m.'
  234.     end
  235.     else
  236.        time := hour+':'+min+':'+sec+' a.m.';
  237.     if H = 12 then
  238.        time := hour+':'+min+':'+sec+' p.m.';
  239. end;
  240.  
  241. {$F+}
  242. Procedure Clock;
  243. {}
  244. begin
  245.     Fastwrite(ClockX,ClockY,attr(ClockF,ClockB),Time);
  246. end; {of proc Clock}
  247. {$F-}
  248.  
  249. function Date: String;
  250. type
  251.   WeekDays = array[0..6]  of string[9];
  252.   Months   = array[1..12] of string[9];
  253. const
  254.     DayNames   : WeekDays  = ('Sunday','Monday','Tuesday','Wednesday',
  255.                               'Thursday','Friday','Saturday');
  256.     MonthNames : Months    = ('January','February','March','April','May',
  257.                               'June','July','August','September',
  258.                               'October','November','December');
  259. var
  260.  Y,
  261.  M,
  262.  D,
  263.  DayOfWeek : word;
  264.  Year   : string;
  265.  Day    : string;
  266. begin
  267.     GetDate(Y,M,D,DayofWeek);
  268.     Str(Y,Year);
  269.     Str(D,Day);
  270.     Date := DayNames[DayOfWeek]+' '+MonthNames[M]+' '+Day+', '+Year;
  271. end;
  272.  
  273. Procedure PrintScreen;
  274. var Regpack : registers;
  275. begin
  276.     intr($05,regpack);
  277. end;
  278.  
  279. procedure Beep;
  280. begin
  281.     sound(800);Delay(150);
  282.     sound(600);Delay(100);
  283.     Nosound;
  284. end;
  285.  
  286. Function Printer_Status:byte;
  287. {Credits: Robert W. Lewis, VA thanks! Special masking employed for non-
  288.           standard printers, e.g. daisy wheels!!! }
  289. var Recpack : registers;
  290. begin
  291.     with recpack do
  292.     begin
  293.         Ah := 2;
  294.         Dx := LPTport;
  295.         intr($17,recpack);
  296.         If (Ah and $B8) = $90 then
  297.            Printer_Status := 0           {all's well}
  298.         else
  299.            If (Ah and $20) = $20 then
  300.               Printer_Status := 1        {no Paper}
  301.         else
  302.            If (Ah and $10) = $00 then
  303.               Printer_Status := 2        {off line}
  304.         else
  305.            If (Ah and $80) = $00 then
  306.               Printer_Status := 3        {busy}
  307.         else
  308.            If (Ah and $08) = $08 then
  309.               Printer_Status := 4;       {undetermined error}
  310.     end;
  311. end;
  312.  
  313. Function Alternate_Printer_Status:byte;
  314. var Recpack : registers;
  315. begin
  316.     with recpack do
  317.     begin
  318.         Ah := 2;
  319.         Dx := LPTport;
  320.         intr($17,recpack);
  321.         If (Ah and $20) = $20 then
  322.               Alternate_Printer_Status := 1        {no Paper}
  323.         else
  324.            If (Ah and $10) = $00 then
  325.               Alternate_Printer_Status := 2        {off line}
  326.         else
  327.            If (Ah and $80) = $00 then
  328.               Alternate_Printer_Status := 3        {busy}
  329.         else
  330.            If (Ah and $08) = $08 then
  331.               Alternate_Printer_Status := 4        {undetermined error}
  332.         else
  333.             Alternate_Printer_Status := 0           {all's well}
  334.     end;
  335. end;
  336.  
  337.  
  338. function printer_ready :boolean;
  339. begin
  340.     Printer_ready := (Printer_Status = 0);
  341. end;
  342.  
  343. Procedure FlushKeyBuffer;
  344. var Recpack : registers;
  345. begin
  346.     with recpack do
  347.     begin
  348.         Ax := ($0c shl 8) or 6;
  349.         Dx := $00ff;
  350.     end;
  351.     Intr($21,recpack);
  352. end;
  353.  
  354. Procedure Reset_Printer;
  355. var address: integer absolute $0040:$0008;
  356.              portno,delay : integer;
  357. begin
  358.     portno := address + 2;
  359.     port[portno] := 232;
  360.     for delay := 1 to 2000 do {nothing};
  361.     port[portno] := 236;
  362. end;
  363.  
  364. {++++++++++++++++++++++++++++++++++}
  365. {                                  }
  366. {    D A T E    R O U T I N E S    }
  367. {                                  }
  368. {++++++++++++++++++++++++++++++++++}
  369.  
  370. (*
  371.  Note that the Julian date logic applied in these routines is that day 1 is
  372.  January 1, 1900. All subsequent dates are represented by the number of
  373.  days elapsed since day 1. The INTERFACE section includes a declaration of
  374.  type DATES - this is set equal to type word, but it could be changed to
  375.  type longint to provide a much greater date range. 
  376.  
  377.  Throughout these procedures and functions a date "format" must be passed. The
  378.  format codes are:
  379.  
  380.                   1  MM/DD/YY
  381.                   2  MM/DD/YYYY
  382.                   3  MM/YY
  383.                   4  MM/YYYY
  384.                   5  DD/MM/YY {International format}
  385.                   6  DD/MM/YYYY   {   "    }
  386.  
  387.  When passing dates in string form the "separators" are not significant. For
  388.  example, the following strings are all treated alike:
  389.  
  390.                      120188
  391.                      12/01/88
  392.                      12-01-88
  393.                      12-01/88
  394.                      12----01----88
  395.  Only the numerical digits are significant, the alphas are ignored.
  396.  
  397. *)
  398.   Function Nth_Number(InStr:string;Nth:byte) : char;
  399.   {Returns the nth number in an alphanumeric string}
  400.   var
  401.      Counter : byte;
  402.      B, Len : byte;
  403.   begin
  404.       Counter := 0;
  405.       B := 0;
  406.       Len := Length(InStr);
  407.       Repeat
  408.            Inc(B);
  409.            If InStr[B] in ['0'..'9'] then
  410.               Inc(Counter);
  411.       Until (Counter = Nth) or (B >= Len);
  412.       If (Counter >= Len) and ( (InStr[Len] in ['0'..'9']) = false) then
  413.          Nth_Number := #0
  414.       else
  415.          Nth_Number := InStr[B];
  416.   end; {of func Nth_Number}
  417.  
  418.  Function Day(DStr:string;Format:byte): word;
  419.  {INTERNAL}
  420.  var
  421.     DayStr: string;
  422.  begin
  423.      Case Format of
  424.      MMDDYY,
  425.      MMDDYYYY :  DayStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  426.      DDMMYY,
  427.      DDMMYYYY :  DayStr := Nth_Number(DStr,1)+Nth_Number(DStr,2);
  428.      else     DayStr := '01';
  429.      end;
  430.      Day := Str_To_Int(DayStr);
  431.  end; {of func Day}
  432.  
  433.  Function Month(DStr:string;Format:byte): word;
  434.  {INTERNAL}
  435.  var
  436.     MonStr: string;
  437.  begin
  438.      Case Format of
  439.      MMDDYY,
  440.      MMDDYYYY,
  441.      MMYY,
  442.      MMYYYY    :  MonStr := Nth_Number(DStr,1)+Nth_Number(DStr,2);
  443.      DDMMYY,
  444.      DDMMYYYY  :  MonStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  445.      end;
  446.      Month := Str_To_Int(MonStr);
  447.  end; {of func Month}
  448.  
  449.  Function Year(DStr:string;Format:byte): word;
  450.  {INTERNAL}
  451.  var
  452.     YrStr   : string;
  453.     TmpYr   : word;
  454.  begin
  455.      Case Format of
  456.      MMDDYY,
  457.      DDMMYY   :  YrStr := Nth_Number(DStr,5)+Nth_Number(DStr,6);
  458.      MMDDYYYY,
  459.      DDMMYYYY :  YrStr := Nth_Number(DStr,5)+Nth_Number(DStr,6)+
  460.                      Nth_Number(DStr,7)+Nth_Number(DStr,8);
  461.      MMYY     :  YrStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  462.      MMYYYY   :  YrStr := Nth_Number(DStr,3)+Nth_Number(DStr,4)+
  463.                      Nth_Number(DStr,5)+Nth_Number(DStr,6);
  464.      end;
  465.      TmpYr := Str_To_Int(YrStr);
  466.      If TmpYr < LastYearNextCentuary then
  467.         TmpYr := 2000 + TmpYr
  468.      else
  469.         If Tmpyr < 1000 then
  470.            TmpYr := 1900 + TmpYr;
  471.      Year := TmpYr;
  472.  end; {of func Year}
  473.  
  474.  Function DMY_to_String(D,M,Y:word;format:byte): string;
  475.  {INTERNAL}
  476.  const
  477.      PadChar = '/';
  478.  var
  479.     DD,MM,YY : string[4];
  480.  begin
  481.      DD := Int_to_Str(D);
  482.      If D < 10 then
  483.         DD := '0'+DD;
  484.      MM := Int_to_Str(M);
  485.      If M < 10 then
  486.         MM := '0'+MM;
  487.      If Format in [MMDDYY,MMYY,DDMMYY] then
  488.      begin
  489.          If Y > 99 then
  490.             If Y > 2000 then
  491.                Y := Y - 2000
  492.             else
  493.                If Y > 1900 then
  494.                   Y := Y - 1900
  495.                else
  496.                   Y := Y Mod 100;
  497.      end
  498.      else
  499.      begin
  500.          If Y < 1900 then
  501.             If Y < LastYearNextCentuary then
  502.                Y := Y + 2000
  503.             else
  504.                Y := Y + 1900;
  505.      end;
  506.      YY := Int_to_Str(Y);
  507.      If Y < 10 then
  508.         YY := '0'+YY;
  509.      Case Format of
  510.      MMDDYY,
  511.      MMDDYYYY: DMY_to_String := MM+PadChar+DD+Padchar+YY;
  512.      MMYY,
  513.      MMYYYY  : DMY_to_String := MM+Padchar+YY;
  514.      DDMMYY,
  515.      DDMMYYYY: DMY_to_String := DD+PadChar+MM+Padchar+YY;
  516.      end; {case}
  517.  end; {of func DMY_to_String}
  518.  
  519.  Function Date_To_Julian(InDate:string;format:byte): dates;
  520.  {Does not check the date is valid. Passed a date string and
  521.   returns a julian date}
  522.  var
  523.     D,M,Y :  word;
  524.     Temp : dates;
  525.  begin
  526.      D := Day(Indate,format);
  527.      M := Month(Indate,format);
  528.      Y := Year(Indate,format);
  529.      If  (Y=1900)
  530.      and (M <= 2) then
  531.      begin
  532.          If M = 1 then
  533.             Temp := pred(D)
  534.          else
  535.             Temp := D+30;
  536.      end
  537.      else
  538.      begin
  539.          If M > 2 then
  540.             M := M - 3
  541.          else
  542.          begin
  543.              M := M + 9;
  544.              dec(Y);
  545.          end;
  546.          Y := Y - 1900;
  547.          Temp := (1461*longint(Y) div 4) +
  548.                  (153*M+2) div 5 +
  549.                  D + 58;
  550.      end;
  551.      Date_to_Julian := Temp;
  552.  end; {of func Date_To_Julian}
  553.  
  554.  Function Julian_to_Date(J:dates;format:byte):string;
  555.  {}
  556.  var
  557.     D,M,Y : word;
  558.     Remainder,Factored : longint;
  559.  begin
  560.      If J = 0 then
  561.      begin
  562.          Case Format of
  563.          DDMMYY,MMDDYY :   Julian_to_date := '  /  /  ';
  564.          DDMMYYYY,MMDDYYYY:Julian_to_date := '  /  /    ';
  565.          MMYYYY:           Julian_to_Date := '  /    ';
  566.          else              Julian_to_date := '  /  ';
  567.          end;
  568.          exit;
  569.      end;
  570.      If J <= 58 then
  571.      begin
  572.          Y := 1900;
  573.          If J <= 30 then
  574.          begin
  575.              M := 1;
  576.              D := succ(J);
  577.          end
  578.          else
  579.          begin
  580.              M := 2;
  581.              D := J - 30;
  582.          end;
  583.      end
  584.      else
  585.      begin
  586.          Factored := 4*LongInt(J) - 233;
  587.          Y := Factored div 1461;
  588.          Remainder := (Factored mod 1461 div 4 * 5) + 2;
  589.          M := Remainder div 153;
  590.          D := succ((Remainder mod 153) div 5);
  591.          Y := Y + 1900;
  592.          If M < 10 then
  593.             M := M + 3
  594.          else
  595.          begin
  596.              M := M - 9;
  597.              Inc(Y);
  598.          end;
  599.      end;
  600.      Julian_to_date := DMY_to_String(D,M,Y,format);
  601.  end; {of proc Julian_to_Date}
  602.  
  603.  Function Date_Within_Range(Min,Max,Test:dates):boolean;
  604.  {}
  605.  begin
  606.      Date_Within_Range := ((Test >= Min) and (Test <= Max));
  607.  end; {of func Date_Within_Range}
  608.  
  609.  Function Valid_Date(Indate:string;format:byte): boolean;
  610.  {}
  611.  var
  612.    D,M,Y : word;
  613.    OK : Boolean;
  614.  begin
  615.      OK := true;  {positive thinking!}
  616.      If format in [MMYY,MMYYYY] then
  617.         D := 1
  618.      else
  619.         D := Day(Indate,format);
  620.      M := Month(Indate,format);
  621.      Y := Year(Indate,format);
  622.      If (D < 1)
  623.      or (D > 31)
  624.      or (M < 1)
  625.      or (M > 12)
  626.      or ((Y > 99) and (Y < 1900))
  627.      or (Y > 2078)
  628.      then 
  629.         OK := False
  630.      else
  631.         Case M of
  632.         4,6,9,11:         OK :=   (D <= 30);
  633.         2:                OK :=   (D <= 28)
  634.                                or (
  635.                                         (D = 29) 
  636.                                     and (Y <> 1900) 
  637.                                     and (Y <> 0)
  638.                                     and (Y mod 4 = 0)
  639.                                   )
  640.         end; {case}
  641.      Valid_Date := OK;
  642.  end; {of func Valid_Date}
  643.  
  644.  Function Today_in_Julian: dates;
  645.  {}
  646.  var
  647.  Y,
  648.  M,
  649.  D,
  650.  DayOfWeek : word;
  651.  Year   : string;
  652.  Day    : string;
  653.  begin
  654.      GetDate(Y,M,D,DayofWeek);
  655.      Today_in_Julian := Date_to_Julian(DMY_to_String(D,M,Y,1),1);
  656.  end; {of func Today_in_Julian}
  657.  
  658.  Function Future_Date(InDate:string;format:byte;Days:word): string;
  659.  {}
  660.  var J : dates;
  661.  begin
  662.      Future_date := Julian_to_date(Date_to_Julian(InDate,Format)+Days,Format);
  663.  end; {of func Future_Date}
  664.  
  665.  Function Unformatted_date(InDate:string): string;
  666.  {strips all non numeric characters}
  667.  var I : Integer;
  668.  
  669.            Function digit(C:char): boolean;
  670.            {}
  671.            begin
  672.                Digit := C in ['0'..'9'];
  673.            end; {of func digit}
  674.  
  675.  begin
  676.      I := 1;
  677.      Repeat
  678.           If (digit(Indate[I]) = false) and (length(Indate) > 0) then
  679.              Delete(Indate,I,1)
  680.           else
  681.              I := succ(I);
  682.      Until (I > length(Indate)) or (Indate = '');
  683.      Unformatted_Date := Indate;
  684.  end; {of func Unformatted_date}
  685.  
  686.  
  687. begin
  688.     ClockX := 67;
  689.     ClockY := 1;
  690.     ClockF := white;
  691.     ClockB := black;
  692.     LPTport := 0;  {LPT1}
  693. end.
  694.